home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / run-program.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  22.6 KB  |  669 lines
  1. ;;; -*- Package: Extensions; Log: code.log  -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: run-program.lisp,v 1.12 92/07/28 00:22:58 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; RUN-PROGRAM and friends.  Facility for running unix programs from inside
  15. ;;; a lisp.
  16. ;;; 
  17. ;;; Written by Jim Healy and Bill Chiles, November 1987, using an earlier
  18. ;;; version written by David McDonald.
  19. ;;;
  20. ;;; Completely re-written by William Lott, July 1989 - January 1990.
  21. ;;;
  22.  
  23. (in-package "EXTENSIONS")
  24.  
  25. (export '(run-program process-status process-exit-code process-core-dumped
  26.       process-wait process-kill process-input process-output process-plist
  27.       process-pty process-error process-status-hook process-alive-p
  28.       process-close process-pid process-p))
  29.  
  30.  
  31. ;;;; Import WAIT3 from unix.
  32.  
  33. (alien:def-alien-routine ("wait3" c-wait3) c-call:int
  34.   (status c-call:int :out)
  35.   (options c-call:int)
  36.   (rusage c-call:int))
  37.  
  38. (eval-when (load eval compile)
  39.   (defconstant wait-wstopped #o177)
  40.   (defconstant wait-wnohang 1)
  41.   (defconstant wait-wuntraced 2))
  42.  
  43. (defun wait3 (&optional do-not-hang check-for-stopped)
  44.   "Return any available status information on child processed. "
  45.   (multiple-value-bind (pid status)
  46.                (c-wait3 (logior (if do-not-hang
  47.                       wait-wnohang
  48.                       0)
  49.                     (if check-for-stopped
  50.                       wait-wuntraced
  51.                       0))
  52.                 0)
  53.     (cond ((or (minusp pid)
  54.            (zerop pid))
  55.        nil)
  56.       ((eql (ldb (byte 8 0) status)
  57.         wait-wstopped)
  58.        (values pid
  59.            :stopped
  60.            (ldb (byte 8 8) status)))
  61.       ((zerop (ldb (byte 7 0) status))
  62.        (values pid
  63.            :exited
  64.            (ldb (byte 8 8) status)))
  65.       (t
  66.        (let ((signal (ldb (byte 7 0) status)))
  67.          (values pid
  68.              (if (or (eql signal unix:sigstop)
  69.                  (eql signal unix:sigtstp)
  70.                  (eql signal unix:sigttin)
  71.                  (eql signal unix:sigttou))
  72.                :stopped
  73.                :signaled)
  74.              signal
  75.              (not (zerop (ldb (byte 1 7) status)))))))))
  76.  
  77.  
  78.  
  79. ;;;; Process control stuff.
  80.  
  81. (defvar *active-processes* nil
  82.   "List of process structures for all active processes.")
  83.  
  84. (defstruct (process (:print-function %print-process))
  85.   pid                ; PID of child process.
  86.   %status            ; Either :RUNNING, :STOPPED, :EXITED, or :SIGNALED.
  87.   exit-code            ; Either exit code or signal
  88.   core-dumped            ; T if a core image was dumped.
  89.   pty                ; Stream to child's pty or nil.
  90.   input                ; Stream to child's input or nil.
  91.   output            ; Stream from child's output or nil.
  92.   error                ; Stream from child's error output or nil.
  93.   status-hook            ; Closure to call when PROC changes status.
  94.   plist                ; Place for clients to stash tings.
  95.   cookie            ; List of the number of pipes from the subproc.
  96.   )
  97.  
  98. (defun %print-process (proc stream depth)
  99.   (declare (ignore depth))
  100.   (format stream "#<process ~D ~S>"
  101.       (process-pid proc)
  102.       (process-status proc)))
  103.  
  104. ;;; PROCESS-STATUS -- Public.
  105. ;;;
  106. (defun process-status (proc)
  107.   "Return the current status of process.  The result is one of :running,
  108.    :stopped, :exited, :signaled."
  109.   (get-processes-status-changes)
  110.   (process-%status proc))
  111.  
  112.  
  113. ;;; PROCESS-WAIT -- Public.
  114. ;;;
  115. (defun process-wait (proc &optional check-for-stopped)
  116.   "Wait for PROC to quit running for some reason.  Returns PROC."
  117.   (loop
  118.     (case (process-status proc)
  119.       (:running)
  120.       (:stopped
  121.        (when check-for-stopped
  122.      (return)))
  123.       (t
  124.        (when (zerop (car (process-cookie proc)))
  125.      (return))))
  126.     (system:serve-all-events 1))
  127.   proc)
  128.  
  129.  
  130. ;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal
  131. ;;;
  132. ;;; Finds the current foreground process group id.
  133. ;;; 
  134. (defun find-current-foreground-process (proc)
  135.   (alien:with-alien ((result c-call:int))
  136.     (multiple-value-bind
  137.     (wonp error)
  138.     (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
  139.              unix:TIOCGPGRP
  140.              (alien:alien-sap (alien:addr result)))
  141.       (unless wonp
  142.     (error "TIOCPGRP ioctl failed: ~S"
  143.            (unix:get-unix-error-msg error)))
  144.       result)))
  145.  
  146. ;;; PROCESS-KILL -- public
  147. ;;;
  148. ;;; Hand a process a signal.
  149. ;;;
  150. (defun process-kill (proc signal &optional (whom :pid))
  151.   "Hand SIGNAL to PROC.  If whom is :pid, use the kill Unix system call.  If
  152.   whom is :process-group, use the killpg Unix system call.  If whom is
  153.   :pty-process-group deliver the signal to whichever process group is currently
  154.   in the foreground."
  155.   (let ((pid (ecase whom
  156.            ((:pid :process-group)
  157.         (process-pid proc))
  158.            (:pty-process-group
  159.         (find-current-foreground-process proc)))))
  160.     (multiple-value-bind (okay errno)
  161.              (if (eq whom :pty-process-group)
  162.                (unix:unix-killpg pid signal)
  163.                (unix:unix-kill pid signal))
  164.       (cond ((not okay)
  165.          (values nil errno))
  166.         ((and (eql pid (process-pid proc))
  167.           (= (unix:unix-signal-number signal) unix:sigcont))
  168.          (setf (process-%status proc) :running)
  169.          (setf (process-exit-code proc) nil)
  170.          (when (process-status-hook proc)
  171.            (funcall (process-status-hook proc) proc))
  172.          t)
  173.         (t
  174.          t)))))
  175.  
  176. ;;; PROCESS-ALIVE-P -- public
  177. ;;;
  178. ;;; Returns T if the process is still alive, NIL otherwise.
  179. ;;; 
  180. (defun process-alive-p (proc)
  181.   "Returns T if the process is still alive, NIL otherwise."
  182.   (let ((status (process-status proc)))
  183.     (if (or (eq status :running)
  184.         (eq status :stopped))
  185.       t
  186.       nil)))
  187.  
  188. ;;; PROCESS-CLOSE -- public
  189. ;;;
  190. ;;; Close all the streams held open by PROC.
  191. ;;; 
  192. (defun process-close (proc)
  193.   "Close all streams connected to PROC and stop maintaining the status slot."
  194.   (macrolet ((frob (stream)
  195.            `(when ,stream (close ,stream))))
  196.     (frob (process-pty proc))
  197.     (frob (process-input proc))
  198.     (frob (process-output proc))
  199.     (frob (process-error proc))
  200.     (system:without-interrupts
  201.       (setf *active-processes* (delete proc *active-processes*)))
  202.     proc))
  203.  
  204. ;;; SIGCHLD-HANDLER -- Internal.
  205. ;;;
  206. ;;; This is the handler for sigchld signals that RUN-PROGRAM establishes.
  207. ;;;
  208. (defun sigchld-handler (ignore1 ignore2 ignore3)
  209.   (declare (ignore ignore1 ignore2 ignore3))
  210.   (get-processes-status-changes))
  211.  
  212. ;;; GET-PROCESSES-STATUS-CHANGES -- Internal.
  213. ;;;
  214. (defun get-processes-status-changes ()
  215.   (loop
  216.     (multiple-value-bind (pid what code core)
  217.              (wait3 t t)
  218.       (unless pid
  219.     (return))
  220.       (let ((proc (find pid *active-processes* :key #'process-pid)))
  221.     (when proc
  222.       (setf (process-%status proc) what)
  223.       (setf (process-exit-code proc) code)
  224.       (setf (process-core-dumped proc) core)
  225.       (when (process-status-hook proc)
  226.         (funcall (process-status-hook proc) proc))
  227.       (when (or (eq what :exited)
  228.             (eq what :signaled))
  229.         (system:without-interrupts
  230.           (setf *active-processes*
  231.             (delete proc *active-processes*)))))))))
  232.  
  233.  
  234.  
  235. ;;;; RUN-PROGRAM and close friends.
  236.  
  237. (defvar *close-on-error* nil
  238.   "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
  239. (defvar *close-in-parent* nil
  240.   "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
  241. (defvar *handlers-installed* nil
  242.   "List of handlers installed by RUN-PROGRAM.")
  243.  
  244.  
  245. ;;; FIND-A-PTY -- internal
  246. ;;;
  247. ;;;   Finds a pty that is not in use. Returns three values: the file descriptor
  248. ;;; for the master side of the pty, the file descriptor for the slave side of
  249. ;;; the pty, and the name of the tty device for the slave side.
  250. ;;; 
  251. (defun find-a-pty ()
  252.   "Returns the master fd, the slave fd, and the name of the tty"
  253.   (dolist (char '(#\p #\q))
  254.     (dotimes (digit 16)
  255.       (let* ((master-name (format nil "/dev/pty~C~X" char digit))
  256.          (master-fd (unix:unix-open master-name
  257.                     unix:o_rdwr
  258.                     #o666)))
  259.     (when master-fd
  260.       (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
  261.          (slave-fd (unix:unix-open slave-name
  262.                        unix:o_rdwr
  263.                        #o666)))
  264.         (when slave-fd
  265.           ; Maybe put a vhangup here?
  266.           (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
  267.         (let ((sap (alien:alien-sap stuff)))
  268.           (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
  269.           (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
  270.           (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
  271.           (unix:unix-ioctl master-fd unix:TIOCGETP sap)
  272.           (setf (alien:slot stuff 'unix:sg-flags)
  273.             (logand (alien:slot stuff 'unix:sg-flags)
  274.                 (lognot 8))) ; ~ECHO
  275.           (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
  276.           (return-from find-a-pty
  277.                (values master-fd
  278.                    slave-fd
  279.                    slave-name)))
  280.       (unix:unix-close master-fd))))))
  281.   (error "Could not find a pty."))
  282.  
  283. ;;; OPEN-PTY -- internal
  284. ;;;
  285. (defun open-pty (pty cookie)
  286.   (when pty
  287.     (multiple-value-bind
  288.     (master slave name)
  289.     (find-a-pty)
  290.       (push master *close-on-error*)
  291.       (push slave *close-in-parent*)
  292.       (when (streamp pty)
  293.     (multiple-value-bind (new-fd errno) (unix:unix-dup master)
  294.       (unless new-fd
  295.         (error "Could not UNIX:UNIX-DUP ~D: ~A"
  296.            master (unix:get-unix-error-msg errno)))
  297.       (push new-fd *close-on-error*)
  298.       (copy-descriptor-to-stream new-fd pty cookie)))
  299.       (values name
  300.           (system:make-fd-stream master :input t :output t)))))
  301.  
  302. ;;; SETUP-CHILD -- internal
  303. ;;;
  304. ;;;   Execs the program after setting up the environment correctly. This
  305. ;;; routine never returns under any condition.
  306. ;;;
  307. (defun setup-child (pfile args env stdin stdout stderr pty-name before-execve)
  308.   (unwind-protect
  309.       (handler-bind ((error #'(lambda (condition)
  310.                 (declare (ignore condition))
  311.                 (unix:unix-exit 2))))
  312.     ;; Put us in our own pgrp.
  313.     (unix:unix-setpgrp 0 (unix:unix-getpid))
  314.     ;; If we want a pty, set it up.
  315.     (when pty-name
  316.       (let ((old-tty (unix:unix-open "/dev/tty" unix:o_rdwr 0)))
  317.         (when old-tty
  318.           (unix:unix-ioctl old-tty unix:TIOCNOTTY nil)
  319.           (unix:unix-close old-tty)))
  320.       (let ((new-tty (unix:unix-open pty-name unix:o_rdwr 0)))
  321.         (when new-tty
  322.           (unix:unix-dup2 new-tty 0)
  323.           (unix:unix-dup2 new-tty 1)
  324.           (unix:unix-dup2 new-tty 2))))
  325.     ;; Setup the three standard descriptors.
  326.     (when stdin
  327.       (unix:unix-dup2 stdin 0))
  328.     (when stdout
  329.       (unix:unix-dup2 stdout 1))
  330.     (when stderr
  331.       (unix:unix-dup2 stderr 2))
  332.     ;; Arange for all the unused FD's to be closed.
  333.     (do ((fd (1- (unix:unix-getdtablesize))
  334.          (1- fd)))
  335.         ((= fd 3))
  336.       (unix:unix-fcntl fd unix:f-setfd 1))
  337.     ;; Do the before-execve
  338.     (when before-execve
  339.       (funcall before-execve))
  340.     ;; Exec the program
  341.     (multiple-value-bind
  342.         (okay errno)
  343.         (unix:unix-execve pfile args env)
  344.       (declare (ignore okay))
  345.       ;; If the magic number if bogus, try just a shell script.
  346.       (when (eql errno unix:ENOEXEC)
  347.         (unix:unix-execve "/bin/sh" (cons pfile args) env))))
  348.     ;; If exec returns, we lose.
  349.     (unix:unix-exit 1)))
  350.  
  351. ;;; RUN-PROGRAM -- public
  352. ;;;
  353. ;;;   RUN-PROGRAM uses fork and execve to run a different program. Strange
  354. ;;; stuff happens to keep the unix state of the world coherent.
  355. ;;;
  356. ;;; The child process needs to get it's input from somewhere, and send it's
  357. ;;; output (both standard and error) to somewhere. We have to do different
  358. ;;; things depending on where these somewheres really are.
  359. ;;;
  360. ;;; For input, there are five options:
  361. ;;; - T: Just leave fd 0 alone. Pretty simple.
  362. ;;; - "file": Read from the file. We need to open the file and pull the
  363. ;;; descriptor out of the stream. The parent should close this stream after
  364. ;;; the child is up and running to free any storage used in the parent.
  365. ;;; - NIL: Same as "file", but use "/dev/null" as the file.
  366. ;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream
  367. ;;; to create the output stream on the writeable descriptor, and pass the
  368. ;;; readable descriptor to the child. The parent must close the readable
  369. ;;; descriptor for EOF to be passed up correctly.
  370. ;;; - a stream: If it's a fd-stream, just pull the descriptor out of it.
  371. ;;; Otherwise make a pipe as in :STREAM, and copy everything across.
  372. ;;;
  373. ;;; For output, there are n options:
  374. ;;; - T: Leave descriptor 1 alone.
  375. ;;; - "file": dump output to the file.
  376. ;;; - NIL: dump output to /dev/null.
  377. ;;; - :STREAM: return a stream that can be read from.
  378. ;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy
  379. ;;; stuff from output to stream.
  380. ;;;
  381. ;;; For error, there are all the same options as output plus:
  382. ;;; - :OUTPUT: redirect to the same place as output.
  383. ;;;
  384. ;;; RUN-PROGRAM returns a process struct for the process if the fork worked,
  385. ;;; and NIL if it did not.
  386. ;;;
  387. (defun run-program (program args
  388.             &key (env *environment-list*) (wait t) pty input
  389.             if-input-does-not-exist output (if-output-exists :error)
  390.             (error :output) (if-error-exists :error) status-hook
  391.             before-execve)
  392.   "Run-program creates a new process and runs the unix progam in the
  393.    file specified by the simple-string program.  Args are the standard
  394.    arguments that can be passed to a Unix program, for no arguments
  395.    use NIL (which means just the name of the program is passed as arg 0).
  396.  
  397.    Run program will either return NIL or a PROCESS structure.  See the CMU
  398.    Common Lisp Users Manual for details about the PROCESS structure.
  399.  
  400.    The keyword arguments have the following meanings:
  401.      :env -
  402.         An A-LIST mapping keyword environment variables to simple-string
  403.     values.
  404.      :wait -
  405.         If non-NIL (default), wait until the created process finishes.  If
  406.         NIL, continue running Lisp until the program finishes.
  407.      :pty -
  408.         Either T, NIL, or a stream.  Unless NIL, the subprocess is established
  409.     under a PTY.  If :pty is a stream, all output to this pty is sent to
  410.     this stream, otherwise the PROCESS-PTY slot is filled in with a stream
  411.     connected to pty that can read output and write input.
  412.      :input -
  413.         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
  414.     input for the current process is inherited.  If NIL, /dev/null
  415.     is used.  If a pathname, the file so specified is used.  If a stream,
  416.     all the input is read from that stream and send to the subprocess.  If
  417.     :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends 
  418.     its output to the process. Defaults to NIL.
  419.      :if-input-does-not-exist (when :input is the name of a file) -
  420.         can be one of:
  421.            :error - generate an error.
  422.            :create - create an empty file.
  423.            nil (default) - return nil from run-program.
  424.      :output -
  425.         Either T, NIL, a pathname, a stream, or :STREAM.  If T, the standard
  426.     input for the current process is inherited.  If NIL, /dev/null
  427.     is used.  If a pathname, the file so specified is used.  If a stream,
  428.     all the output from the process is written to this stream. If
  429.     :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
  430.     be read to get the output. Defaults to NIL.
  431.      :if-output-exists (when :input is the name of a file) -
  432.         can be one of:
  433.            :error (default) - generates an error if the file already exists.
  434.            :supersede - output from the program supersedes the file.
  435.            :append - output from the program is appended to the file.
  436.            nil - run-program returns nil without doing anything.
  437.      :error and :if-error-exists - 
  438.         Same as :output and :if-output-exists, except that :error can also be
  439.     specified as :output in which case all error output is routed to the
  440.     same place as normal output.
  441.      :status-hook -
  442.         This is a function the system calls whenever the status of the
  443.         process changes.  The function takes the process as an argument.
  444.      :before-execve -
  445.         This is a function, without arguments, RUN-PROGRAM runs in the child
  446.         process just before turning it into the specified program."
  447.  
  448.   ;; Make sure the interrupt handler is installed.
  449.   (system:enable-interrupt unix:sigchld #'sigchld-handler)
  450.   ;; Make sure all the args are okay.
  451.   (unless (every #'simple-string-p args)
  452.     (error "All args to program must be simple strings -- ~S." args))
  453.   ;; Pre-pend the program to the argument list.
  454.   (push (namestring program) args)
  455.   ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
  456.   ;; info.  Also, establish proc at this level so we can return it.
  457.   (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
  458.     (unwind-protect
  459.     (let ((pfile (namestring (truename (merge-pathnames program "path:"))))
  460.           (cookie (list 0)))
  461.       (multiple-value-bind
  462.           (stdin input-stream)
  463.           (get-descriptor-for input cookie :direction :input
  464.                   :if-does-not-exist if-input-does-not-exist)
  465.         (multiple-value-bind
  466.         (stdout output-stream)
  467.         (get-descriptor-for output cookie :direction :output
  468.                     :if-exists if-output-exists)
  469.           (multiple-value-bind
  470.           (stderr error-stream)
  471.           (if (eq error :output)
  472.               (values stdout output-stream)
  473.               (get-descriptor-for error cookie :direction :output
  474.                       :if-exists if-error-exists))
  475.         (multiple-value-bind (pty-name pty-stream)
  476.                      (open-pty pty cookie)
  477.           ;; Make sure we are not notified about the child death before
  478.           ;; we have installed the process struct in *active-processes*
  479.           (system:without-interrupts
  480.             (multiple-value-bind
  481.             (child-pid errno)
  482.             (unix:unix-fork)
  483.               (cond ((null child-pid)
  484.                  ;; This should only happen if the bozo has too
  485.                  ;; many running procs.
  486.                  (error "Could not fork child process: ~A"
  487.                     (unix:get-unix-error-msg errno)))
  488.                 ((zerop child-pid)
  489.                  ;; We are the child. Note: setup-child NEVER
  490.                  ;; returns
  491.                  (setup-child pfile args env stdin stdout stderr
  492.                       pty-name before-execve))
  493.                 (t
  494.                  ;; We are the parent.
  495.                  (setf proc (make-process :pid child-pid
  496.                               :%status :running
  497.                               :pty pty-stream
  498.                               :input input-stream
  499.                               :output output-stream
  500.                               :error error-stream
  501.                               :status-hook status-hook
  502.                               :cookie cookie))
  503.                  (push proc *active-processes*))))))))))
  504.       (dolist (fd *close-in-parent*)
  505.     (unix:unix-close fd))
  506.       (unless proc
  507.     (dolist (fd *close-on-error*)
  508.       (unix:unix-close fd))
  509.     (dolist (handler *handlers-installed*)
  510.       (system:remove-fd-handler handler))))
  511.     (when (and wait proc)
  512.       (process-wait proc))
  513.     proc))
  514.  
  515. ;;; COPY-DESCRIPTOR-TO-STREAM -- internal
  516. ;;;
  517. ;;;   Installs a handler for any input that shows up on the file descriptor.
  518. ;;; The handler reads the data and writes it to the stream.
  519. ;;; 
  520. (defun copy-descriptor-to-stream (descriptor stream cookie)
  521.   (incf (car cookie))
  522.   (let ((string (make-string 256))
  523.     handler)
  524.     (setf handler
  525.       (system:add-fd-handler descriptor :input
  526.         #'(lambda (fd)
  527.         (declare (ignore fd))
  528.         (loop
  529.           (unless handler
  530.             (return))
  531.           (multiple-value-bind
  532.               (result readable/errno)
  533.               (unix:unix-select (1+ descriptor) (ash 1 descriptor)
  534.                     0 0 0)
  535.             (cond ((null result)
  536.                (error "Could not select on sub-process: ~A"
  537.                   (unix:get-unix-error-msg readable/errno)))
  538.               ((zerop result)
  539.                (return))))
  540.           (alien:with-alien ((buf (alien:array c-call:char 256)))
  541.             (multiple-value-bind
  542.             (count errno)
  543.             (unix:unix-read descriptor (alien-sap buf) 256)
  544.               (cond ((or (and (null count)
  545.                       (eql errno unix:eio))
  546.                  (eql count 0))
  547.                  (system:remove-fd-handler handler)
  548.                  (setf handler nil)
  549.                  (decf (car cookie))
  550.                  (unix:unix-close descriptor)
  551.                  (return))
  552.                 ((null count)
  553.                  (system:remove-fd-handler handler)
  554.                  (setf handler nil)
  555.                  (decf (car cookie))
  556.                  (error "Could not read input from sub-process: ~A"
  557.                     (unix:get-unix-error-msg errno)))
  558.                 (t
  559.                  (kernel:copy-from-system-area
  560.                   (alien-sap buf) 0
  561.                   string (* vm:vector-data-offset vm:word-bits)
  562.                   (* count vm:byte-bits))
  563.                  (write-string string stream
  564.                        :end count)))))))))))
  565.  
  566. ;;; GET-DESCRIPTOR-FOR -- internal
  567. ;;;
  568. ;;;   Find a file descriptor to use for object given the direction. Returns
  569. ;;; the descriptor. If object is :STREAM, returns the created stream as the
  570. ;;; second value.
  571. ;;; 
  572. (defun get-descriptor-for (object cookie &rest keys &key direction
  573.                   &allow-other-keys)
  574.   (cond ((eq object t)
  575.      ;; No new descriptor is needed.
  576.      (values nil nil))
  577.     ((eq object nil)
  578.      ;; Use /dev/null.
  579.      (multiple-value-bind
  580.          (fd errno)
  581.          (unix:unix-open "/dev/null"
  582.                  (case direction
  583.                    (:input unix:o_rdonly)
  584.                    (:output unix:o_wronly)
  585.                    (t unix:o_rdwr))
  586.                  #o666)
  587.        (unless fd
  588.          (error "Could not open \"/dev/null\": ~A"
  589.             (unix:get-unix-error-msg errno)))
  590.        (push fd *close-in-parent*)
  591.        (values fd nil)))
  592.     ((eq object :stream)
  593.      (multiple-value-bind
  594.          (read-fd write-fd)
  595.          (unix:unix-pipe)
  596.        (unless read-fd
  597.          (error "Could not create pipe: ~A"
  598.             (unix:get-unix-error-msg write-fd)))
  599.        (case direction
  600.          (:input
  601.           (push read-fd *close-in-parent*)
  602.           (push write-fd *close-on-error*)
  603.           (let ((stream (system:make-fd-stream write-fd :output t)))
  604.         (values read-fd stream)))
  605.          (:output
  606.           (push read-fd *close-on-error*)
  607.           (push write-fd *close-in-parent*)
  608.           (let ((stream (system:make-fd-stream read-fd :input t)))
  609.         (values write-fd stream)))
  610.          (t
  611.           (unix:unix-close read-fd)
  612.           (unix:unix-close write-fd)
  613.           (error "Direction must be either :INPUT or :OUTPUT, not ~S"
  614.              direction)))))
  615.     ((or (pathnamep object) (stringp object))
  616.      (with-open-stream (file (apply #'open object keys))
  617.        (multiple-value-bind
  618.            (fd errno)
  619.            (unix:unix-dup (system:fd-stream-fd file))
  620.          (cond (fd
  621.             (push fd *close-in-parent*)
  622.             (values fd nil))
  623.            (t
  624.             (error "Could not duplicate file descriptor: ~A"
  625.                (unix:get-unix-error-msg errno)))))))
  626.     ((system:fd-stream-p object)
  627.      (values (system:fd-stream-fd object) nil))
  628.     ((streamp object)
  629.      (ecase direction
  630.        (:input
  631.         (dotimes (count
  632.               256
  633.               (error "Could not open a temporary file in /tmp"))
  634.           (let* ((name (format nil "/tmp/.run-program-~D" count))
  635.              (fd (unix:unix-open name
  636.                      (logior unix:o_rdwr
  637.                          unix:o_creat
  638.                          unix:o_excl)
  639.                      #o666)))
  640.         (unix:unix-unlink name)
  641.         (when fd
  642.           (let ((newline (string #\Newline)))
  643.             (loop
  644.               (multiple-value-bind
  645.               (line no-cr)
  646.               (read-line object nil nil)
  647.             (unless line
  648.               (return))
  649.             (unix:unix-write fd line 0 (length line))
  650.             (if no-cr
  651.               (return)
  652.               (unix:unix-write fd newline 0 1)))))
  653.           (unix:unix-lseek fd 0 unix:l_set)
  654.           (push fd *close-in-parent*)
  655.           (return (values fd nil))))))
  656.        (:output
  657.         (multiple-value-bind (read-fd write-fd)
  658.                  (unix:unix-pipe)
  659.           (unless read-fd
  660.         (error "Cound not create pipe: ~A"
  661.                (unix:get-unix-error-msg write-fd)))
  662.           (copy-descriptor-to-stream read-fd object cookie)
  663.           (push read-fd *close-on-error*)
  664.           (push write-fd *close-in-parent*)
  665.           (values write-fd nil)))))
  666.     (t
  667.      (error "Invalid option to run-program: ~S" object))))
  668.  
  669.